home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tcl7.4 / tclCmdIL.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-06-28  |  36.8 KB  |  1,443 lines
  1. /* 
  2.  * tclCmdIL.c --
  3.  *
  4.  *    This file contains the top-level command routines for most of
  5.  *    the Tcl built-in commands whose names begin with the letters
  6.  *    I through L.  It contains only commands in the generic core
  7.  *    (i.e. those that don't depend much upon UNIX facilities).
  8.  *
  9.  * Copyright (c) 1987-1993 The Regents of the University of California.
  10.  * Copyright (c) 1994-1995 Sun Microsystems, Inc.
  11.  *
  12.  * See the file "license.terms" for information on usage and redistribution
  13.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14.  */
  15.  
  16. #ifndef lint
  17. static char sccsid[] = "@(#) tclCmdIL.c 1.111 95/06/28 13:36:42";
  18. #endif
  19.  
  20. #include "tclInt.h"
  21. #include "tclPort.h"
  22.  
  23. /*
  24.  * The variables below are used to implement the "lsort" command.
  25.  * Unfortunately, this use of static variables prevents "lsort"
  26.  * from being thread-safe, but there's no alternative given the
  27.  * current implementation of qsort.  In a threaded environment
  28.  * these variables should be made thread-local if possible, or else
  29.  * "lsort" needs internal mutual exclusion.
  30.  */
  31.  
  32. static Tcl_Interp *sortInterp = NULL;    /* Interpreter for "lsort" command. 
  33.                      * NULL means no lsort is active. */
  34. static enum {ASCII, INTEGER, REAL, COMMAND} sortMode;
  35.                     /* Mode for sorting: compare as strings,
  36.                      * compare as numbers, or call
  37.                      * user-defined command for
  38.                      * comparison. */
  39. static Tcl_DString sortCmd;        /* Holds command if mode is COMMAND.
  40.                      * pre-initialized to hold base of
  41.                      * command. */
  42. static int sortIncreasing;        /* 0 means sort in decreasing order,
  43.                      * 1 means increasing order. */
  44. static int sortCode;            /* Anything other than TCL_OK means a
  45.                      * problem occurred while sorting; this
  46.                      * executing a comparison command, so
  47.                      * the sort was aborted. */
  48.  
  49. /*
  50.  * Forward declarations for procedures defined in this file:
  51.  */
  52.  
  53. static int        SortCompareProc _ANSI_ARGS_((CONST VOID *first,
  54.                 CONST VOID *second));
  55.  
  56. /*
  57.  *----------------------------------------------------------------------
  58.  *
  59.  * Tcl_IfCmd --
  60.  *
  61.  *    This procedure is invoked to process the "if" Tcl command.
  62.  *    See the user documentation for details on what it does.
  63.  *
  64.  * Results:
  65.  *    A standard Tcl result.
  66.  *
  67.  * Side effects:
  68.  *    See the user documentation.
  69.  *
  70.  *----------------------------------------------------------------------
  71.  */
  72.  
  73.     /* ARGSUSED */
  74. int
  75. Tcl_IfCmd(dummy, interp, argc, argv)
  76.     ClientData dummy;            /* Not used. */
  77.     Tcl_Interp *interp;            /* Current interpreter. */
  78.     int argc;                /* Number of arguments. */
  79.     char **argv;            /* Argument strings. */
  80. {
  81.     int i, result, value;
  82.  
  83.     i = 1;
  84.     while (1) {
  85.     /*
  86.      * At this point in the loop, argv and argc refer to an expression
  87.      * to test, either for the main expression or an expression
  88.      * following an "elseif".  The arguments after the expression must
  89.      * be "then" (optional) and a script to execute if the expression is
  90.      * true.
  91.      */
  92.  
  93.     if (i >= argc) {
  94.         Tcl_AppendResult(interp, "wrong # args: no expression after \"",
  95.             argv[i-1], "\" argument", (char *) NULL);
  96.         return TCL_ERROR;
  97.     }
  98.     result = Tcl_ExprBoolean(interp, argv[i], &value);
  99.     if (result != TCL_OK) {
  100.         return result;
  101.     }
  102.     i++;
  103.     if ((i < argc) && (strcmp(argv[i], "then") == 0)) {
  104.         i++;
  105.     }
  106.     if (i >= argc) {
  107.         Tcl_AppendResult(interp, "wrong # args: no script following \"",
  108.             argv[i-1], "\" argument", (char *) NULL);
  109.         return TCL_ERROR;
  110.     }
  111.     if (value) {
  112.         return Tcl_Eval(interp, argv[i]);
  113.     }
  114.  
  115.     /*
  116.      * The expression evaluated to false.  Skip the command, then
  117.      * see if there is an "else" or "elseif" clause.
  118.      */
  119.  
  120.     i++;
  121.     if (i >= argc) {
  122.         return TCL_OK;
  123.     }
  124.     if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) {
  125.         i++;
  126.         continue;
  127.     }
  128.     break;
  129.     }
  130.  
  131.     /*
  132.      * Couldn't find a "then" or "elseif" clause to execute.  Check now
  133.      * for an "else" clause.  We know that there's at least one more
  134.      * argument when we get here.
  135.      */
  136.  
  137.     if (strcmp(argv[i], "else") == 0) {
  138.     i++;
  139.     if (i >= argc) {
  140.         Tcl_AppendResult(interp,
  141.             "wrong # args: no script following \"else\" argument",
  142.             (char *) NULL);
  143.         return TCL_ERROR;
  144.     }
  145.     }
  146.     return Tcl_Eval(interp, argv[i]);
  147. }
  148.  
  149. /*
  150.  *----------------------------------------------------------------------
  151.  *
  152.  * Tcl_IncrCmd --
  153.  *
  154.  *    This procedure is invoked to process the "incr" Tcl command.
  155.  *    See the user documentation for details on what it does.
  156.  *
  157.  * Results:
  158.  *    A standard Tcl result.
  159.  *
  160.  * Side effects:
  161.  *    See the user documentation.
  162.  *
  163.  *----------------------------------------------------------------------
  164.  */
  165.  
  166.     /* ARGSUSED */
  167. int
  168. Tcl_IncrCmd(dummy, interp, argc, argv)
  169.     ClientData dummy;            /* Not used. */
  170.     Tcl_Interp *interp;            /* Current interpreter. */
  171.     int argc;                /* Number of arguments. */
  172.     char **argv;            /* Argument strings. */
  173. {
  174.     int value;
  175.     char *oldString, *result;
  176.     char newString[30];
  177.  
  178.     if ((argc != 2) && (argc != 3)) {
  179.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  180.         " varName ?increment?\"", (char *) NULL);
  181.     return TCL_ERROR;
  182.     }
  183.  
  184.     oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
  185.     if (oldString == NULL) {
  186.     return TCL_ERROR;
  187.     }
  188.     if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
  189.     Tcl_AddErrorInfo(interp,
  190.         "\n    (reading value of variable to increment)");
  191.     return TCL_ERROR;
  192.     }
  193.     if (argc == 2) {
  194.     value += 1;
  195.     } else {
  196.     int increment;
  197.  
  198.     if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
  199.         Tcl_AddErrorInfo(interp,
  200.             "\n    (reading increment)");
  201.         return TCL_ERROR;
  202.     }
  203.     value += increment;
  204.     }
  205.     sprintf(newString, "%d", value);
  206.     result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
  207.     if (result == NULL) {
  208.     return TCL_ERROR;
  209.     }
  210.     interp->result = result;
  211.     return TCL_OK; 
  212. }
  213.  
  214. /*
  215.  *----------------------------------------------------------------------
  216.  *
  217.  * Tcl_InfoCmd --
  218.  *
  219.  *    This procedure is invoked to process the "info" Tcl command.
  220.  *    See the user documentation for details on what it does.
  221.  *
  222.  * Results:
  223.  *    A standard Tcl result.
  224.  *
  225.  * Side effects:
  226.  *    See the user documentation.
  227.  *
  228.  *----------------------------------------------------------------------
  229.  */
  230.  
  231.     /* ARGSUSED */
  232. int
  233. Tcl_InfoCmd(dummy, interp, argc, argv)
  234.     ClientData dummy;            /* Not used. */
  235.     Tcl_Interp *interp;            /* Current interpreter. */
  236.     int argc;                /* Number of arguments. */
  237.     char **argv;            /* Argument strings. */
  238. {
  239.     register Interp *iPtr = (Interp *) interp;
  240.     size_t length;
  241.     int c;
  242.     Arg *argPtr;
  243.     Proc *procPtr;
  244.     Var *varPtr;
  245.     Command *cmdPtr;
  246.     Tcl_HashEntry *hPtr;
  247.     Tcl_HashSearch search;
  248.  
  249.     if (argc < 2) {
  250.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  251.         " option ?arg arg ...?\"", (char *) NULL);
  252.     return TCL_ERROR;
  253.     }
  254.     c = argv[1][0];
  255.     length = strlen(argv[1]);
  256.     if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {
  257.     if (argc != 3) {
  258.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  259.             argv[0], " args procname\"", (char *) NULL);
  260.         return TCL_ERROR;
  261.     }
  262.     procPtr = TclFindProc(iPtr, argv[2]);
  263.     if (procPtr == NULL) {
  264.         infoNoSuchProc:
  265.         Tcl_AppendResult(interp, "\"", argv[2],
  266.             "\" isn't a procedure", (char *) NULL);
  267.         return TCL_ERROR;
  268.     }
  269.     for (argPtr = procPtr->argPtr; argPtr != NULL;
  270.         argPtr = argPtr->nextPtr) {
  271.         Tcl_AppendElement(interp, argPtr->name);
  272.     }
  273.     return TCL_OK;
  274.     } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {
  275.     if (argc != 3) {
  276.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  277.             " body procname\"", (char *) NULL);
  278.         return TCL_ERROR;
  279.     }
  280.     procPtr = TclFindProc(iPtr, argv[2]);
  281.     if (procPtr == NULL) {
  282.         goto infoNoSuchProc;
  283.     }
  284.     iPtr->result = procPtr->command;
  285.     return TCL_OK;
  286.     } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)
  287.         && (length >= 2)) {
  288.     if (argc != 2) {
  289.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  290.             " cmdcount\"", (char *) NULL);
  291.         return TCL_ERROR;
  292.     }
  293.     sprintf(iPtr->result, "%d", iPtr->cmdCount);
  294.     return TCL_OK;
  295.     } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)
  296.         && (length >= 4)) {
  297.     if (argc > 3) {
  298.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  299.             " commands [pattern]\"", (char *) NULL);
  300.         return TCL_ERROR;
  301.     }
  302.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  303.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  304.         char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
  305.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  306.         continue;
  307.         }
  308.         Tcl_AppendElement(interp, name);
  309.     }
  310.     return TCL_OK;
  311.     } else if ((c == 'c') && (strncmp(argv[1], "complete", length) == 0)
  312.         && (length >= 4)) {
  313.     if (argc != 3) {
  314.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  315.             " complete command\"", (char *) NULL);
  316.         return TCL_ERROR;
  317.     }
  318.     if (Tcl_CommandComplete(argv[2])) {
  319.         interp->result = "1";
  320.     } else {
  321.         interp->result = "0";
  322.     }
  323.     return TCL_OK;
  324.     } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {
  325.     if (argc != 5) {
  326.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  327.             argv[0], " default procname arg varname\"",
  328.             (char *) NULL);
  329.         return TCL_ERROR;
  330.     }
  331.     procPtr = TclFindProc(iPtr, argv[2]);
  332.     if (procPtr == NULL) {
  333.         goto infoNoSuchProc;
  334.     }
  335.     for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) {
  336.         if (argPtr == NULL) {
  337.         Tcl_AppendResult(interp, "procedure \"", argv[2],
  338.             "\" doesn't have an argument \"", argv[3],
  339.             "\"", (char *) NULL);
  340.         return TCL_ERROR;
  341.         }
  342.         if (strcmp(argv[3], argPtr->name) == 0) {
  343.         if (argPtr->defValue != NULL) {
  344.             if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4],
  345.                 argPtr->defValue, 0) == NULL) {
  346.             defStoreError:
  347.             Tcl_AppendResult(interp,
  348.                 "couldn't store default value in variable \"",
  349.                 argv[4], "\"", (char *) NULL);
  350.             return TCL_ERROR;
  351.             }
  352.             iPtr->result = "1";
  353.         } else {
  354.             if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0)
  355.                 == NULL) {
  356.             goto defStoreError;
  357.             }
  358.             iPtr->result = "0";
  359.         }
  360.         return TCL_OK;
  361.         }
  362.     }
  363.     } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
  364.     char *p;
  365.     if (argc != 3) {
  366.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  367.             " exists varName\"", (char *) NULL);
  368.         return TCL_ERROR;
  369.     }
  370.     p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0);
  371.  
  372.     /*
  373.      * The code below handles the special case where the name is for
  374.      * an array:  Tcl_GetVar will reject this since you can't read
  375.      * an array variable without an index.
  376.      */
  377.  
  378.     if (p == NULL) {
  379.         Tcl_HashEntry *hPtr;
  380.         Var *varPtr;
  381.  
  382.         if (strchr(argv[2], '(') != NULL) {
  383.         noVar:
  384.         iPtr->result = "0";
  385.         return TCL_OK;
  386.         }
  387.         if (iPtr->varFramePtr == NULL) {
  388.         hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
  389.         } else {
  390.         hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
  391.         }
  392.         if (hPtr == NULL) {
  393.         goto noVar;
  394.         }
  395.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  396.         if (varPtr->flags & VAR_UPVAR) {
  397.         varPtr = varPtr->value.upvarPtr;
  398.         }
  399.         if (!(varPtr->flags & VAR_ARRAY)) {
  400.         goto noVar;
  401.         }
  402.     }
  403.     iPtr->result = "1";
  404.     return TCL_OK;
  405.     } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
  406.     char *name;
  407.  
  408.     if (argc > 3) {
  409.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  410.             " globals [pattern]\"", (char *) NULL);
  411.         return TCL_ERROR;
  412.     }
  413.     for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search);
  414.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  415.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  416.         if (varPtr->flags & VAR_UNDEFINED) {
  417.         continue;
  418.         }
  419.         name = Tcl_GetHashKey(&iPtr->globalTable, hPtr);
  420.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  421.         continue;
  422.         }
  423.         Tcl_AppendElement(interp, name);
  424.     }
  425.     return TCL_OK;
  426.     } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)
  427.         && (length >= 2)) {
  428.     if (argc == 2) {
  429.         if (iPtr->varFramePtr == NULL) {
  430.         iPtr->result = "0";
  431.         } else {
  432.         sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);
  433.         }
  434.         return TCL_OK;
  435.     } else if (argc == 3) {
  436.         int level;
  437.         CallFrame *framePtr;
  438.  
  439.         if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) {
  440.         return TCL_ERROR;
  441.         }
  442.         if (level <= 0) {
  443.         if (iPtr->varFramePtr == NULL) {
  444.             levelError:
  445.             Tcl_AppendResult(interp, "bad level \"", argv[2],
  446.                 "\"", (char *) NULL);
  447.             return TCL_ERROR;
  448.         }
  449.         level += iPtr->varFramePtr->level;
  450.         }
  451.         for (framePtr = iPtr->varFramePtr; framePtr != NULL;
  452.             framePtr = framePtr->callerVarPtr) {
  453.         if (framePtr->level == level) {
  454.             break;
  455.         }
  456.         }
  457.         if (framePtr == NULL) {
  458.         goto levelError;
  459.         }
  460.         iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);
  461.         iPtr->freeProc = (Tcl_FreeProc *) free;
  462.         return TCL_OK;
  463.     }
  464.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  465.         " level [number]\"", (char *) NULL);
  466.     return TCL_ERROR;
  467.     } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0)
  468.         && (length >= 2)) {
  469.     if (argc != 2) {
  470.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  471.             " library\"", (char *) NULL);
  472.         return TCL_ERROR;
  473.     }
  474.     interp->result = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
  475.     if (interp->result == NULL) {
  476.         interp->result = "no library has been specified for Tcl";
  477.         return TCL_ERROR;
  478.     }
  479.     return TCL_OK;
  480.     } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
  481.         && (length >= 2)) {
  482.     char *name;
  483.  
  484.     if (argc > 3) {
  485.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  486.             " locals [pattern]\"", (char *) NULL);
  487.         return TCL_ERROR;
  488.     }
  489.     if (iPtr->varFramePtr == NULL) {
  490.         return TCL_OK;
  491.     }
  492.     for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search);
  493.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  494.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  495.         if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) {
  496.         continue;
  497.         }
  498.         name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr);
  499.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  500.         continue;
  501.         }
  502.         Tcl_AppendElement(interp, name);
  503.     }
  504.     return TCL_OK;
  505.     } else if ((c == 'p') && (strncmp(argv[1], "patchlevel", length) == 0)
  506.         && (length >= 2)) {
  507.     char *value;
  508.  
  509.     if (argc != 2) {
  510.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  511.             " patchlevel\"", (char *) NULL);
  512.         return TCL_ERROR;
  513.     }
  514.     value = Tcl_GetVar(interp, "tcl_patchLevel",
  515.         TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
  516.     if (value == NULL) {
  517.         return TCL_ERROR;
  518.     }
  519.     interp->result = value;
  520.     return TCL_OK;
  521.     } else if ((c == 'p') && (strncmp(argv[1], "procs", length) == 0)
  522.         && (length >= 2)) {
  523.     if (argc > 3) {
  524.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  525.             " procs [pattern]\"", (char *) NULL);
  526.         return TCL_ERROR;
  527.     }
  528.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  529.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  530.         char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
  531.  
  532.         cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  533.         if (!TclIsProc(cmdPtr)) {
  534.         continue;
  535.         }
  536.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  537.         continue;
  538.         }
  539.         Tcl_AppendElement(interp, name);
  540.     }
  541.     return TCL_OK;
  542.     } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) {
  543.     if (argc != 2) {
  544.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  545.             argv[0], " script\"", (char *) NULL);
  546.         return TCL_ERROR;
  547.     }
  548.     if (iPtr->scriptFile != NULL) {
  549.         /*
  550.          * Can't depend on iPtr->scriptFile to be non-volatile:
  551.          * if this command is returned as the result of the script,
  552.          * then iPtr->scriptFile will go away.
  553.          */
  554.  
  555.         Tcl_SetResult(interp, iPtr->scriptFile, TCL_VOLATILE);
  556.     }
  557.     return TCL_OK;
  558.     } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
  559.     char *value;
  560.  
  561.     if (argc != 2) {
  562.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  563.             argv[0], " tclversion\"", (char *) NULL);
  564.         return TCL_ERROR;
  565.     }
  566.     value = Tcl_GetVar(interp, "tcl_version",
  567.         TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
  568.     if (value == NULL) {
  569.         return TCL_ERROR;
  570.     }
  571.     interp->result = value;
  572.     return TCL_OK;
  573.     } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {
  574.     Tcl_HashTable *tablePtr;
  575.     char *name;
  576.  
  577.     if (argc > 3) {
  578.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  579.             argv[0], " vars [pattern]\"", (char *) NULL);
  580.         return TCL_ERROR;
  581.     }
  582.     if (iPtr->varFramePtr == NULL) {
  583.         tablePtr = &iPtr->globalTable;
  584.     } else {
  585.         tablePtr = &iPtr->varFramePtr->varTable;
  586.     }
  587.     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
  588.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  589.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  590.         if (varPtr->flags & VAR_UNDEFINED) {
  591.         continue;
  592.         }
  593.         name = Tcl_GetHashKey(tablePtr, hPtr);
  594.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  595.         continue;
  596.         }
  597.         Tcl_AppendElement(interp, name);
  598.     }
  599.     return TCL_OK;
  600.     } else {
  601.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  602.         "\": should be args, body, cmdcount, commands, ",
  603.         "complete, default, ",
  604.         "exists, globals, level, library, locals, ",
  605.         "patchlevel, procs, script, tclversion, or vars",
  606.         (char *) NULL);
  607.     return TCL_ERROR;
  608.     }
  609. }
  610.  
  611. /*
  612.  *----------------------------------------------------------------------
  613.  *
  614.  * Tcl_JoinCmd --
  615.  *
  616.  *    This procedure is invoked to process the "join" Tcl command.
  617.  *    See the user documentation for details on what it does.
  618.  *
  619.  * Results:
  620.  *    A standard Tcl result.
  621.  *
  622.  * Side effects:
  623.  *    See the user documentation.
  624.  *
  625.  *----------------------------------------------------------------------
  626.  */
  627.  
  628.     /* ARGSUSED */
  629. int
  630. Tcl_JoinCmd(dummy, interp, argc, argv)
  631.     ClientData dummy;            /* Not used. */
  632.     Tcl_Interp *interp;            /* Current interpreter. */
  633.     int argc;                /* Number of arguments. */
  634.     char **argv;            /* Argument strings. */
  635. {
  636.     char *joinString;
  637.     char **listArgv;
  638.     int listArgc, i;
  639.  
  640.     if (argc == 2) {
  641.     joinString = " ";
  642.     } else if (argc == 3) {
  643.     joinString = argv[2];
  644.     } else {
  645.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  646.         " list ?joinString?\"", (char *) NULL);
  647.     return TCL_ERROR;
  648.     }
  649.  
  650.     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
  651.     return TCL_ERROR;
  652.     }
  653.     for (i = 0; i < listArgc; i++) {
  654.     if (i == 0) {
  655.         Tcl_AppendResult(interp, listArgv[0], (char *) NULL);
  656.     } else  {
  657.         Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL);
  658.     }
  659.     }
  660.     ckfree((char *) listArgv);
  661.     return TCL_OK;
  662. }
  663.  
  664. /*
  665.  *----------------------------------------------------------------------
  666.  *
  667.  * Tcl_LindexCmd --
  668.  *
  669.  *    This procedure is invoked to process the "lindex" Tcl command.
  670.  *    See the user documentation for details on what it does.
  671.  *
  672.  * Results:
  673.  *    A standard Tcl result.
  674.  *
  675.  * Side effects:
  676.  *    See the user documentation.
  677.  *
  678.  *----------------------------------------------------------------------
  679.  */
  680.  
  681.     /* ARGSUSED */
  682. int
  683. Tcl_LindexCmd(dummy, interp, argc, argv)
  684.     ClientData dummy;            /* Not used. */
  685.     Tcl_Interp *interp;            /* Current interpreter. */
  686.     int argc;                /* Number of arguments. */
  687.     char **argv;            /* Argument strings. */
  688. {
  689.     char *p, *element, *next;
  690.     int index, size, parenthesized, result, returnLast;
  691.  
  692.     if (argc != 3) {
  693.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  694.         " list index\"", (char *) NULL);
  695.     return TCL_ERROR;
  696.     }
  697.     if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) {
  698.     returnLast = 1;
  699.     index = INT_MAX;
  700.     } else {
  701.     returnLast = 0;
  702.     if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
  703.         return TCL_ERROR;
  704.     }
  705.     }
  706.     if (index < 0) {
  707.     return TCL_OK;
  708.     }
  709.     for (p = argv[1] ; index >= 0; index--) {
  710.     result = TclFindElement(interp, p, &element, &next, &size,
  711.         &parenthesized);
  712.     if (result != TCL_OK) {
  713.         return result;
  714.     }
  715.     if ((*next == 0) && returnLast) {
  716.         break;
  717.     }
  718.     p = next;
  719.     }
  720.     if (size == 0) {
  721.     return TCL_OK;
  722.     }
  723.     if (size >= TCL_RESULT_SIZE) {
  724.     interp->result = (char *) ckalloc((unsigned) size+1);
  725.     interp->freeProc = (Tcl_FreeProc *) free;
  726.     }
  727.     if (parenthesized) {
  728.     memcpy((VOID *) interp->result, (VOID *) element, (size_t) size);
  729.     interp->result[size] = 0;
  730.     } else {
  731.     TclCopyAndCollapse(size, element, interp->result);
  732.     }
  733.     return TCL_OK;
  734. }
  735.  
  736. /*
  737.  *----------------------------------------------------------------------
  738.  *
  739.  * Tcl_LinsertCmd --
  740.  *
  741.  *    This procedure is invoked to process the "linsert" Tcl command.
  742.  *    See the user documentation for details on what it does.
  743.  *
  744.  * Results:
  745.  *    A standard Tcl result.
  746.  *
  747.  * Side effects:
  748.  *    See the user documentation.
  749.  *
  750.  *----------------------------------------------------------------------
  751.  */
  752.  
  753.     /* ARGSUSED */
  754. int
  755. Tcl_LinsertCmd(dummy, interp, argc, argv)
  756.     ClientData dummy;            /* Not used. */
  757.     Tcl_Interp *interp;            /* Current interpreter. */
  758.     int argc;                /* Number of arguments. */
  759.     char **argv;            /* Argument strings. */
  760. {
  761.     char *p, *element, savedChar;
  762.     int i, index, count, result, size;
  763.  
  764.     if (argc < 4) {
  765.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  766.         " list index element ?element ...?\"", (char *) NULL);
  767.     return TCL_ERROR;
  768.     }
  769.     if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) {
  770.     index = INT_MAX;
  771.     } else if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
  772.     return TCL_ERROR;
  773.     }
  774.  
  775.     /*
  776.      * Skip over the first "index" elements of the list, then add
  777.      * all of those elements to the result.
  778.      */
  779.  
  780.     size = 0;
  781.     element = argv[1];
  782.     for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) {
  783.     result = TclFindElement(interp, p, &element, &p, &size, (int *) NULL);
  784.     if (result != TCL_OK) {
  785.         return result;
  786.     }
  787.     }
  788.     if (*p == 0) {
  789.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  790.     } else {
  791.     char *end;
  792.  
  793.     end = element+size;
  794.     if (element != argv[1]) {
  795.         while ((*end != 0) && !isspace(UCHAR(*end))) {
  796.         end++;
  797.         }
  798.     }
  799.     savedChar = *end;
  800.     *end = 0;
  801.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  802.     *end = savedChar;
  803.     }
  804.  
  805.     /*
  806.      * Add the new list elements.
  807.      */
  808.  
  809.     for (i = 3; i < argc; i++) {
  810.     Tcl_AppendElement(interp, argv[i]);
  811.     }
  812.  
  813.     /*
  814.      * Append the remainder of the original list.
  815.      */
  816.  
  817.     if (*p != 0) {
  818.     Tcl_AppendResult(interp, " ", p, (char *) NULL);
  819.     }
  820.     return TCL_OK;
  821. }
  822.  
  823. /*
  824.  *----------------------------------------------------------------------
  825.  *
  826.  * Tcl_ListCmd --
  827.  *
  828.  *    This procedure is invoked to process the "list" Tcl command.
  829.  *    See the user documentation for details on what it does.
  830.  *
  831.  * Results:
  832.  *    A standard Tcl result.
  833.  *
  834.  * Side effects:
  835.  *    See the user documentation.
  836.  *
  837.  *----------------------------------------------------------------------
  838.  */
  839.  
  840.     /* ARGSUSED */
  841. int
  842. Tcl_ListCmd(dummy, interp, argc, argv)
  843.     ClientData dummy;            /* Not used. */
  844.     Tcl_Interp *interp;            /* Current interpreter. */
  845.     int argc;                /* Number of arguments. */
  846.     char **argv;            /* Argument strings. */
  847. {
  848.     if (argc >= 2) {
  849.     interp->result = Tcl_Merge(argc-1, argv+1);
  850.     interp->freeProc = (Tcl_FreeProc *) free;
  851.     }
  852.     return TCL_OK;
  853. }
  854.  
  855. /*
  856.  *----------------------------------------------------------------------
  857.  *
  858.  * Tcl_LlengthCmd --
  859.  *
  860.  *    This procedure is invoked to process the "llength" Tcl command.
  861.  *    See the user documentation for details on what it does.
  862.  *
  863.  * Results:
  864.  *    A standard Tcl result.
  865.  *
  866.  * Side effects:
  867.  *    See the user documentation.
  868.  *
  869.  *----------------------------------------------------------------------
  870.  */
  871.  
  872.     /* ARGSUSED */
  873. int
  874. Tcl_LlengthCmd(dummy, interp, argc, argv)
  875.     ClientData dummy;            /* Not used. */
  876.     Tcl_Interp *interp;            /* Current interpreter. */
  877.     int argc;                /* Number of arguments. */
  878.     char **argv;            /* Argument strings. */
  879. {
  880.     int count, result;
  881.     char *element, *p;
  882.  
  883.     if (argc != 2) {
  884.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  885.         " list\"", (char *) NULL);
  886.     return TCL_ERROR;
  887.     }
  888.     for (count = 0, p = argv[1]; *p != 0 ; count++) {
  889.     result = TclFindElement(interp, p, &element, &p, (int *) NULL,
  890.         (int *) NULL);
  891.     if (result != TCL_OK) {
  892.         return result;
  893.     }
  894.     if (*element == 0) {
  895.         break;
  896.     }
  897.     }
  898.     sprintf(interp->result, "%d", count);
  899.     return TCL_OK;
  900. }
  901.  
  902. /*
  903.  *----------------------------------------------------------------------
  904.  *
  905.  * Tcl_LrangeCmd --
  906.  *
  907.  *    This procedure is invoked to process the "lrange" Tcl command.
  908.  *    See the user documentation for details on what it does.
  909.  *
  910.  * Results:
  911.  *    A standard Tcl result.
  912.  *
  913.  * Side effects:
  914.  *    See the user documentation.
  915.  *
  916.  *----------------------------------------------------------------------
  917.  */
  918.  
  919.     /* ARGSUSED */
  920. int
  921. Tcl_LrangeCmd(notUsed, interp, argc, argv)
  922.     ClientData notUsed;            /* Not used. */
  923.     Tcl_Interp *interp;            /* Current interpreter. */
  924.     int argc;                /* Number of arguments. */
  925.     char **argv;            /* Argument strings. */
  926. {
  927.     int first, last, result;
  928.     char *begin, *end, c, *dummy, *next;
  929.     int count, firstIsEnd;
  930.  
  931.     if (argc != 4) {
  932.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  933.         " list first last\"", (char *) NULL);
  934.     return TCL_ERROR;
  935.     }
  936.     if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) {
  937.     firstIsEnd = 1;
  938.     first = INT_MAX;
  939.     } else {
  940.     firstIsEnd = 0;
  941.     if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
  942.         return TCL_ERROR;
  943.     }
  944.     }
  945.     if (first < 0) {
  946.     first = 0;
  947.     }
  948.     if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
  949.     last = INT_MAX;
  950.     } else {
  951.     if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) {
  952.         Tcl_ResetResult(interp);
  953.         Tcl_AppendResult(interp, "expected integer or \"end\" but got \"",
  954.             argv[3], "\"", (char *) NULL);
  955.         return TCL_ERROR;
  956.     }
  957.     }
  958.     if ((first > last) && !firstIsEnd) {
  959.     return TCL_OK;
  960.     }
  961.  
  962.     /*
  963.      * Extract a range of fields.
  964.      */
  965.  
  966.     for (count = 0, begin = argv[1]; count < first; begin = next, count++) {
  967.     result = TclFindElement(interp, begin, &dummy, &next, (int *) NULL,
  968.         (int *) NULL);
  969.     if (result != TCL_OK) {
  970.         return result;
  971.     }
  972.     if (*next == 0) {
  973.         if (firstIsEnd) {
  974.         first = count;
  975.         } else {
  976.         begin = next;
  977.         }
  978.         break;
  979.     }
  980.     }
  981.     for (count = first, end = begin; (count <= last) && (*end != 0);
  982.         count++) {
  983.     result = TclFindElement(interp, end, &dummy, &end, (int *) NULL,
  984.         (int *) NULL);
  985.     if (result != TCL_OK) {
  986.         return result;
  987.     }
  988.     }
  989.     if (end == begin) {
  990.     return TCL_OK;
  991.     }
  992.  
  993.     /*
  994.      * Chop off trailing spaces.
  995.      */
  996.  
  997.     while (isspace(UCHAR(end[-1]))) {
  998.     end--;
  999.     }
  1000.     c = *end;
  1001.     *end = 0;
  1002.     Tcl_SetResult(interp, begin, TCL_VOLATILE);
  1003.     *end = c;
  1004.     return TCL_OK;
  1005. }
  1006.  
  1007. /*
  1008.  *----------------------------------------------------------------------
  1009.  *
  1010.  * Tcl_LreplaceCmd --
  1011.  *
  1012.  *    This procedure is invoked to process the "lreplace" Tcl command.
  1013.  *    See the user documentation for details on what it does.
  1014.  *
  1015.  * Results:
  1016.  *    A standard Tcl result.
  1017.  *
  1018.  * Side effects:
  1019.  *    See the user documentation.
  1020.  *
  1021.  *----------------------------------------------------------------------
  1022.  */
  1023.  
  1024.     /* ARGSUSED */
  1025. int
  1026. Tcl_LreplaceCmd(notUsed, interp, argc, argv)
  1027.     ClientData notUsed;            /* Not used. */
  1028.     Tcl_Interp *interp;            /* Current interpreter. */
  1029.     int argc;                /* Number of arguments. */
  1030.     char **argv;            /* Argument strings. */
  1031. {
  1032.     char *p1, *p2, *element, savedChar, *dummy, *next;
  1033.     int i, first, last, count, result, size, firstIsEnd;
  1034.  
  1035.     if (argc < 4) {
  1036.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1037.         " list first last ?element element ...?\"", (char *) NULL);
  1038.     return TCL_ERROR;
  1039.     }
  1040.     if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) {
  1041.     firstIsEnd = 1;
  1042.     first = INT_MAX;
  1043.     } else {
  1044.     firstIsEnd = 0;
  1045.     if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
  1046.         return TCL_ERROR;
  1047.     }
  1048.     }
  1049.     if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
  1050.     last = INT_MAX;
  1051.     } else {
  1052.     if (TclGetListIndex(interp, argv[3], &last) != TCL_OK) {
  1053.         return TCL_ERROR;
  1054.     }
  1055.     }
  1056.     if (first < 0) {
  1057.     first = 0;
  1058.     }
  1059.     if (last < 0) {
  1060.     last = 0;
  1061.     }
  1062.  
  1063.     /*
  1064.      * Skip over the elements of the list before "first".
  1065.      */
  1066.  
  1067.     size = 0;
  1068.     element = argv[1];
  1069.     for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) {
  1070.     result = TclFindElement(interp, p1, &element, &next, &size,
  1071.         (int *) NULL);
  1072.     if (result != TCL_OK) {
  1073.         return result;
  1074.     }
  1075.     if ((*next == 0) && firstIsEnd) {
  1076.         break;
  1077.     }
  1078.     p1 = next;
  1079.     }
  1080.     if (*p1 == 0) {
  1081.     Tcl_AppendResult(interp, "list doesn't contain element ",
  1082.         argv[2], (char *) NULL);
  1083.     return TCL_ERROR;
  1084.     }
  1085.     if (count > last) {
  1086.     Tcl_AppendResult(interp, "first index must not be greater than second",
  1087.         (char *) NULL);
  1088.     return TCL_ERROR;
  1089.     }
  1090.  
  1091.     /*
  1092.      * Skip over the elements of the list up through "last".
  1093.      */
  1094.  
  1095.     for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) {
  1096.     result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL,
  1097.         (int *) NULL);
  1098.     if (result != TCL_OK) {
  1099.         return result;
  1100.     }
  1101.     }
  1102.  
  1103.     /*
  1104.      * Add the elements before "first" to the result.  Drop any terminating
  1105.      * white space, since a separator will be added below, if needed.
  1106.      */
  1107.  
  1108.     while ((p1 != argv[1]) && (isspace(UCHAR(p1[-1])))) {
  1109.     p1--;
  1110.     }
  1111.     savedChar = *p1;
  1112.     *p1 = 0;
  1113.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  1114.     *p1 = savedChar;
  1115.  
  1116.     /*
  1117.      * Add the new list elements.
  1118.      */
  1119.  
  1120.     for (i = 4; i < argc; i++) {
  1121.     Tcl_AppendElement(interp, argv[i]);
  1122.     }
  1123.  
  1124.     /*
  1125.      * Append the remainder of the original list.
  1126.      */
  1127.  
  1128.     if (*p2 != 0) {
  1129.     if (*interp->result == 0) {
  1130.         Tcl_SetResult(interp, p2, TCL_VOLATILE);
  1131.     } else {
  1132.         Tcl_AppendResult(interp, " ", p2, (char *) NULL);
  1133.     }
  1134.     }
  1135.     return TCL_OK;
  1136. }
  1137.  
  1138. /*
  1139.  *----------------------------------------------------------------------
  1140.  *
  1141.  * Tcl_LsearchCmd --
  1142.  *
  1143.  *    This procedure is invoked to process the "lsearch" Tcl command.
  1144.  *    See the user documentation for details on what it does.
  1145.  *
  1146.  * Results:
  1147.  *    A standard Tcl result.
  1148.  *
  1149.  * Side effects:
  1150.  *    See the user documentation.
  1151.  *
  1152.  *----------------------------------------------------------------------
  1153.  */
  1154.  
  1155.     /* ARGSUSED */
  1156. int
  1157. Tcl_LsearchCmd(notUsed, interp, argc, argv)
  1158.     ClientData notUsed;            /* Not used. */
  1159.     Tcl_Interp *interp;            /* Current interpreter. */
  1160.     int argc;                /* Number of arguments. */
  1161.     char **argv;            /* Argument strings. */
  1162. {
  1163. #define EXACT    0
  1164. #define GLOB    1
  1165. #define REGEXP    2
  1166.     int listArgc;
  1167.     char **listArgv;
  1168.     int i, match, mode, index;
  1169.  
  1170.     mode = GLOB;
  1171.     if (argc == 4) {
  1172.     if (strcmp(argv[1], "-exact") == 0) {
  1173.         mode = EXACT;
  1174.     } else if (strcmp(argv[1], "-glob") == 0) {
  1175.         mode = GLOB;
  1176.     } else if (strcmp(argv[1], "-regexp") == 0) {
  1177.         mode = REGEXP;
  1178.     } else {
  1179.         Tcl_AppendResult(interp, "bad search mode \"", argv[1],
  1180.             "\": must be -exact, -glob, or -regexp", (char *) NULL);
  1181.         return TCL_ERROR;
  1182.     }
  1183.     } else if (argc != 3) {
  1184.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1185.         " ?mode? list pattern\"", (char *) NULL);
  1186.     return TCL_ERROR;
  1187.     }
  1188.     if (Tcl_SplitList(interp, argv[argc-2], &listArgc, &listArgv) != TCL_OK) {
  1189.     return TCL_ERROR;
  1190.     }
  1191.     index = -1;
  1192.     for (i = 0; i < listArgc; i++) {
  1193.     match = 0;
  1194.     switch (mode) {
  1195.         case EXACT:
  1196.         match = (strcmp(listArgv[i], argv[argc-1]) == 0);
  1197.         break;
  1198.         case GLOB:
  1199.         match = Tcl_StringMatch(listArgv[i], argv[argc-1]);
  1200.         break;
  1201.         case REGEXP:
  1202.         match = Tcl_RegExpMatch(interp, listArgv[i], argv[argc-1]);
  1203.         if (match < 0) {
  1204.             ckfree((char *) listArgv);
  1205.             return TCL_ERROR;
  1206.         }
  1207.         break;
  1208.     }
  1209.     if (match) {
  1210.         index = i;
  1211.         break;
  1212.     }
  1213.     }
  1214.     sprintf(interp->result, "%d", index);
  1215.     ckfree((char *) listArgv);
  1216.     return TCL_OK;
  1217. }
  1218.  
  1219. /*
  1220.  *----------------------------------------------------------------------
  1221.  *
  1222.  * Tcl_LsortCmd --
  1223.  *
  1224.  *    This procedure is invoked to process the "lsort" Tcl command.
  1225.  *    See the user documentation for details on what it does.
  1226.  *
  1227.  * Results:
  1228.  *    A standard Tcl result.
  1229.  *
  1230.  * Side effects:
  1231.  *    See the user documentation.
  1232.  *
  1233.  *----------------------------------------------------------------------
  1234.  */
  1235.  
  1236.     /* ARGSUSED */
  1237. int
  1238. Tcl_LsortCmd(notUsed, interp, argc, argv)
  1239.     ClientData notUsed;            /* Not used. */
  1240.     Tcl_Interp *interp;            /* Current interpreter. */
  1241.     int argc;                /* Number of arguments. */
  1242.     char **argv;            /* Argument strings. */
  1243. {
  1244.     int listArgc, i, c;
  1245.     size_t length;
  1246.     char **listArgv;
  1247.     char *command = NULL;        /* Initialization needed only to
  1248.                      * prevent compiler warning. */
  1249.  
  1250.     if (argc < 2) {
  1251.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1252.         " ?-ascii? ?-integer? ?-real? ?-increasing? ?-decreasing?",
  1253.         " ?-command string? list\"", (char *) NULL);
  1254.     return TCL_ERROR;
  1255.     }
  1256.  
  1257.     if (sortInterp != NULL) {
  1258.     interp->result = "can't invoke \"lsort\" recursively";
  1259.     return TCL_ERROR;
  1260.     }
  1261.  
  1262.     /*
  1263.      * Parse arguments to set up the mode for the sort.
  1264.      */
  1265.  
  1266.     sortInterp = interp;
  1267.     sortMode = ASCII;
  1268.     sortIncreasing = 1;
  1269.     sortCode = TCL_OK;
  1270.     for (i = 1; i < argc-1; i++) {
  1271.     length = strlen(argv[i]);
  1272.     if (length < 2) {
  1273.         badSwitch:
  1274.         Tcl_AppendResult(interp, "bad switch \"", argv[i],
  1275.             "\": must be -ascii, -integer, -real, -increasing",
  1276.             " -decreasing, or -command", (char *) NULL);
  1277.         sortCode = TCL_ERROR;
  1278.         goto done;
  1279.     }
  1280.     c = argv[i][1];
  1281.     if ((c == 'a') && (strncmp(argv[i], "-ascii", length) == 0)) {
  1282.         sortMode = ASCII;
  1283.     } else if ((c == 'c') && (strncmp(argv[i], "-command", length) == 0)) {
  1284.         if (i == argc-2) {
  1285.         Tcl_AppendResult(interp, "\"-command\" must be",
  1286.             " followed by comparison command", (char *) NULL);
  1287.         sortCode = TCL_ERROR;
  1288.         goto done;
  1289.         }
  1290.         sortMode = COMMAND;
  1291.         command = argv[i+1];
  1292.         i++;
  1293.     } else if ((c == 'd')
  1294.         && (strncmp(argv[i], "-decreasing", length) == 0)) {
  1295.         sortIncreasing = 0;
  1296.     } else if ((c == 'i') && (length >= 4)
  1297.         && (strncmp(argv[i], "-increasing", length) == 0)) {
  1298.         sortIncreasing = 1;
  1299.     } else if ((c == 'i') && (length >= 4)
  1300.         && (strncmp(argv[i], "-integer", length) == 0)) {
  1301.         sortMode = INTEGER;
  1302.     } else if ((c == 'r')
  1303.         && (strncmp(argv[i], "-real", length) == 0)) {
  1304.         sortMode = REAL;
  1305.     } else {
  1306.         goto badSwitch;
  1307.     }
  1308.     }
  1309.     if (sortMode == COMMAND) {
  1310.     Tcl_DStringInit(&sortCmd);
  1311.     Tcl_DStringAppend(&sortCmd, command, -1);
  1312.     }
  1313.  
  1314.     if (Tcl_SplitList(interp, argv[argc-1], &listArgc, &listArgv) != TCL_OK) {
  1315.     sortCode = TCL_ERROR;
  1316.     goto done;
  1317.     }
  1318.     qsort((VOID *) listArgv, (size_t) listArgc, sizeof (char *),
  1319.         SortCompareProc);
  1320.     if (sortCode == TCL_OK) {
  1321.     Tcl_ResetResult(interp);
  1322.     interp->result = Tcl_Merge(listArgc, listArgv);
  1323.     interp->freeProc = (Tcl_FreeProc *) free;
  1324.     }
  1325.     if (sortMode == COMMAND) {
  1326.     Tcl_DStringFree(&sortCmd);
  1327.     }
  1328.     ckfree((char *) listArgv);
  1329.  
  1330.     done:
  1331.     sortInterp = NULL;
  1332.     return sortCode;
  1333. }
  1334.  
  1335. /*
  1336.  *----------------------------------------------------------------------
  1337.  *
  1338.  * SortCompareProc --
  1339.  *
  1340.  *    This procedure is invoked by qsort to determine the proper
  1341.  *    ordering between two elements.
  1342.  *
  1343.  * Results:
  1344.  *    < 0 means first is "smaller" than "second", > 0 means "first"
  1345.  *    is larger than "second", and 0 means they should be treated
  1346.  *    as equal.
  1347.  *
  1348.  * Side effects:
  1349.  *    None, unless a user-defined comparison command does something
  1350.  *    weird.
  1351.  *
  1352.  *----------------------------------------------------------------------
  1353.  */
  1354.  
  1355. static int
  1356. SortCompareProc(first, second)
  1357.     CONST VOID *first, *second;        /* Elements to be compared. */
  1358. {
  1359.     int order;
  1360.     char *firstString = *((char **) first);
  1361.     char *secondString = *((char **) second);
  1362.  
  1363.     order = 0;
  1364.     if (sortCode != TCL_OK) {
  1365.     /*
  1366.      * Once an error has occurred, skip any future comparisons
  1367.      * so as to preserve the error message in sortInterp->result.
  1368.      */
  1369.  
  1370.     return order;
  1371.     }
  1372.     if (sortMode == ASCII) {
  1373.     order = strcmp(firstString, secondString);
  1374.     } else if (sortMode == INTEGER) {
  1375.     int a, b;
  1376.  
  1377.     if ((Tcl_GetInt(sortInterp, firstString, &a) != TCL_OK)
  1378.         || (Tcl_GetInt(sortInterp, secondString, &b) != TCL_OK)) {
  1379.         Tcl_AddErrorInfo(sortInterp,
  1380.             "\n    (converting list element from string to integer)");
  1381.         sortCode = TCL_ERROR;
  1382.         return order;
  1383.     }
  1384.     if (a > b) {
  1385.         order = 1;
  1386.     } else if (b > a) {
  1387.         order = -1;
  1388.     }
  1389.     } else if (sortMode == REAL) {
  1390.     double a, b;
  1391.  
  1392.     if ((Tcl_GetDouble(sortInterp, firstString, &a) != TCL_OK)
  1393.         || (Tcl_GetDouble(sortInterp, secondString, &b) != TCL_OK)) {
  1394.         Tcl_AddErrorInfo(sortInterp,
  1395.             "\n    (converting list element from string to real)");
  1396.         sortCode = TCL_ERROR;
  1397.         return order;
  1398.     }
  1399.     if (a > b) {
  1400.         order = 1;
  1401.     } else if (b > a) {
  1402.         order = -1;
  1403.     }
  1404.     } else {
  1405.     int oldLength;
  1406.     char *end;
  1407.  
  1408.     /*
  1409.      * Generate and evaluate a command to determine which string comes
  1410.      * first.
  1411.      */
  1412.  
  1413.     oldLength = Tcl_DStringLength(&sortCmd);
  1414.     Tcl_DStringAppendElement(&sortCmd, firstString);
  1415.     Tcl_DStringAppendElement(&sortCmd, secondString);
  1416.     sortCode = Tcl_Eval(sortInterp, Tcl_DStringValue(&sortCmd));
  1417.     Tcl_DStringTrunc(&sortCmd, oldLength);
  1418.     if (sortCode != TCL_OK) {
  1419.         Tcl_AddErrorInfo(sortInterp,
  1420.             "\n    (user-defined comparison command)");
  1421.         return order;
  1422.     }
  1423.  
  1424.     /*
  1425.      * Parse the result of the command.
  1426.      */
  1427.  
  1428.     order = strtol(sortInterp->result, &end, 0);
  1429.     if ((end == sortInterp->result) || (*end != 0)) {
  1430.         Tcl_ResetResult(sortInterp);
  1431.         Tcl_AppendResult(sortInterp,
  1432.             "comparison command returned non-numeric result",
  1433.             (char *) NULL);
  1434.         sortCode = TCL_ERROR;
  1435.         return order;
  1436.     }
  1437.     }
  1438.     if (!sortIncreasing) {
  1439.     order = -order;
  1440.     }
  1441.     return order;
  1442. }
  1443.